home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / src / tclUtil.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-11-07  |  51.6 KB  |  2,061 lines  |  [TEXT/MPS ]
  1. #ifdef MPW
  2. #    pragma segment TCL_UTIL
  3. #endif
  4.  
  5. /* 
  6.  * tclUtil.c --
  7.  *
  8.  *    This file contains utility procedures that are used by many Tcl
  9.  *    commands.
  10.  *
  11.  * Copyright (c) 1987-1993 The Regents of the University of California.
  12.  * All rights reserved.
  13.  *
  14.  * Permission is hereby granted, without written agreement and without
  15.  * license or royalty fees, to use, copy, modify, and distribute this
  16.  * software and its documentation for any purpose, provided that the
  17.  * above copyright notice and the following two paragraphs appear in
  18.  * all copies of this software.
  19.  * 
  20.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  21.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  22.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  23.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  24.  *
  25.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  26.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  27.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  28.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  29.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  30.  */
  31.  
  32. #ifndef lint
  33. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUtil.c,v 1.82 93/09/17 15:58:32 ouster Exp $ SPRITE (Berkeley)";
  34. #endif
  35.  
  36. #include "tclInt.h"
  37.  
  38. /*
  39.  * The following values are used in the flags returned by Tcl_ScanElement
  40.  * and used by Tcl_ConvertElement.  The value TCL_DONT_USE_BRACES is also
  41.  * defined in tcl.h;  make sure its value doesn't overlap with any of the
  42.  * values below.
  43.  *
  44.  * TCL_DONT_USE_BRACES -    1 means the string mustn't be enclosed in
  45.  *                braces (e.g. it contains unmatched braces,
  46.  *                or ends in a backslash character, or user
  47.  *                just doesn't want braces);  handle all
  48.  *                special characters by adding backslashes.
  49.  * USE_BRACES -            1 means the string contains a special
  50.  *                character that can be handled simply by
  51.  *                enclosing the entire argument in braces.
  52.  * BRACES_UNMATCHED -        1 means that braces aren't properly matched
  53.  *                in the argument.
  54.  */
  55.  
  56. #define USE_BRACES        2
  57. #define BRACES_UNMATCHED    4
  58.  
  59. /*
  60.  * The variable below is set to NULL before invoking regexp functions
  61.  * and checked after those functions.  If an error occurred then TclRegError
  62.  * will set the variable to point to a (static) error message.  This
  63.  * mechanism unfortunately does not support multi-threading, but then
  64.  * neither does the rest of the regexp facilities.
  65.  */
  66.  
  67. char *tclRegexpError = NULL;
  68.  
  69. /*
  70.  * Function prototypes for local procedures in this file:
  71.  */
  72.  
  73. static void        SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
  74.                 int newSpace));
  75.  
  76. /*
  77.  *----------------------------------------------------------------------
  78.  *
  79.  * TclFindElement --
  80.  *
  81.  *    Given a pointer into a Tcl list, locate the first (or next)
  82.  *    element in the list.
  83.  *
  84.  * Results:
  85.  *    The return value is normally TCL_OK, which means that the
  86.  *    element was successfully located.  If TCL_ERROR is returned
  87.  *    it means that list didn't have proper list structure;
  88.  *    interp->result contains a more detailed error message.
  89.  *
  90.  *    If TCL_OK is returned, then *elementPtr will be set to point
  91.  *    to the first element of list, and *nextPtr will be set to point
  92.  *    to the character just after any white space following the last
  93.  *    character that's part of the element.  If this is the last argument
  94.  *    in the list, then *nextPtr will point to the NULL character at the
  95.  *    end of list.  If sizePtr is non-NULL, *sizePtr is filled in with
  96.  *    the number of characters in the element.  If the element is in
  97.  *    braces, then *elementPtr will point to the character after the
  98.  *    opening brace and *sizePtr will not include either of the braces.
  99.  *    If there isn't an element in the list, *sizePtr will be zero, and
  100.  *    both *elementPtr and *termPtr will refer to the null character at
  101.  *    the end of list.  Note:  this procedure does NOT collapse backslash
  102.  *    sequences.
  103.  *
  104.  * Side effects:
  105.  *    None.
  106.  *
  107.  *----------------------------------------------------------------------
  108.  */
  109.  
  110. int
  111. TclFindElement(interp, list, elementPtr, nextPtr, sizePtr, bracePtr)
  112.     Tcl_Interp *interp;        /* Interpreter to use for error reporting. */
  113.     register char *list;    /* String containing Tcl list with zero
  114.                  * or more elements (possibly in braces). */
  115.     char **elementPtr;        /* Fill in with location of first significant
  116.                  * character in first element of list. */
  117.     char **nextPtr;        /* Fill in with location of character just
  118.                  * after all white space following end of
  119.                  * argument (i.e. next argument or end of
  120.                  * list). */
  121.     int *sizePtr;        /* If non-zero, fill in with size of
  122.                  * element. */
  123.     int *bracePtr;        /* If non-zero fill in with non-zero/zero
  124.                  * to indicate that arg was/wasn't
  125.                  * in braces. */
  126. {
  127.     register char *p;
  128.     int openBraces = 0;
  129.     int inQuotes = 0;
  130.     int size;
  131.  
  132.     /*
  133.      * Skim off leading white space and check for an opening brace or
  134.      * quote.   Note:  use of "isascii" below and elsewhere in this
  135.      * procedure is a temporary hack (7/27/90) because Mx uses characters
  136.      * with the high-order bit set for some things.  This should probably
  137.      * be changed back eventually, or all of Tcl should call isascii.
  138.      */
  139.  
  140.     while (isspace(UCHAR(*list))) {
  141.     list++;
  142.     }
  143.     if (*list == '{') {
  144.     openBraces = 1;
  145.     list++;
  146.     } else if (*list == '"') {
  147.     inQuotes = 1;
  148.     list++;
  149.     }
  150.     if (bracePtr != 0) {
  151.     *bracePtr = openBraces;
  152.     }
  153.     p = list;
  154.  
  155.     /*
  156.      * Find the end of the element (either a space or a close brace or
  157.      * the end of the string).
  158.      */
  159.  
  160.     while (1) {
  161.     switch (*p) {
  162.  
  163.         /*
  164.          * Open brace: don't treat specially unless the element is
  165.          * in braces.  In this case, keep a nesting count.
  166.          */
  167.  
  168.         case '{':
  169.         if (openBraces != 0) {
  170.             openBraces++;
  171.         }
  172.         break;
  173.  
  174.         /*
  175.          * Close brace: if element is in braces, keep nesting
  176.          * count and quit when the last close brace is seen.
  177.          */
  178.  
  179.         case '}':
  180.         if (openBraces == 1) {
  181.             char *p2;
  182.  
  183.             size = p - list;
  184.             p++;
  185.             if (isspace(UCHAR(*p)) || (*p == 0)) {
  186.             goto done;
  187.             }
  188.             for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2)))
  189.                 && (p2 < p+20); p2++) {
  190.             /* null body */
  191.             }
  192.             Tcl_ResetResult(interp);
  193.             sprintf(interp->result,
  194.                 "list element in braces followed by \"%.*s\" instead of space",
  195.                 p2-p, p);
  196.             return TCL_ERROR;
  197.         } else if (openBraces != 0) {
  198.             openBraces--;
  199.         }
  200.         break;
  201.  
  202.         /*
  203.          * Backslash:  skip over everything up to the end of the
  204.          * backslash sequence.
  205.          */
  206.  
  207.         case '\\': {
  208.         int size;
  209.  
  210.         (void) Tcl_Backslash(p, &size);
  211.         p += size - 1;
  212.         break;
  213.         }
  214.  
  215.         /*
  216.          * Space: ignore if element is in braces or quotes;  otherwise
  217.          * terminate element.
  218.          */
  219.  
  220.         case ' ':
  221.         case '\f':
  222.         case '\n':
  223.         case '\r':
  224.         case '\t':
  225.         case '\v':
  226.         if ((openBraces == 0) && !inQuotes) {
  227.             size = p - list;
  228.             goto done;
  229.         }
  230.         break;
  231.  
  232.         /*
  233.          * Double-quote:  if element is in quotes then terminate it.
  234.          */
  235.  
  236.         case '"':
  237.         if (inQuotes) {
  238.             char *p2;
  239.  
  240.             size = p-list;
  241.             p++;
  242.             if (isspace(UCHAR(*p)) || (*p == 0)) {
  243.             goto done;
  244.             }
  245.             for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2)))
  246.                 && (p2 < p+20); p2++) {
  247.             /* null body */
  248.             }
  249.             Tcl_ResetResult(interp);
  250.             sprintf(interp->result,
  251.                 "list element in quotes followed by \"%.*s\" %s",
  252.                 p2-p, p, "instead of space");
  253.             return TCL_ERROR;
  254.         }
  255.         break;
  256.  
  257.         /*
  258.          * End of list:  terminate element.
  259.          */
  260.  
  261.         case 0:
  262.         if (openBraces != 0) {
  263.             Tcl_SetResult(interp, "unmatched open brace in list",
  264.                 TCL_STATIC);
  265.             return TCL_ERROR;
  266.         } else if (inQuotes) {
  267.             Tcl_SetResult(interp, "unmatched open quote in list",
  268.                 TCL_STATIC);
  269.             return TCL_ERROR;
  270.         }
  271.         size = p - list;
  272.         goto done;
  273.  
  274.     }
  275.     p++;
  276.     }
  277.  
  278.     done:
  279.     while (isspace(UCHAR(*p))) {
  280.     p++;
  281.     }
  282.     *elementPtr = list;
  283.     *nextPtr = p;
  284.     if (sizePtr != 0) {
  285.     *sizePtr = size;
  286.     }
  287.     return TCL_OK;
  288. }
  289.  
  290. /*
  291.  *----------------------------------------------------------------------
  292.  *
  293.  * TclCopyAndCollapse --
  294.  *
  295.  *    Copy a string and eliminate any backslashes that aren't in braces.
  296.  *
  297.  * Results:
  298.  *    There is no return value.  Count chars. get copied from src
  299.  *    to dst.  Along the way, if backslash sequences are found outside
  300.  *    braces, the backslashes are eliminated in the copy.
  301.  *    After scanning count chars. from source, a null character is
  302.  *    placed at the end of dst.
  303.  *
  304.  * Side effects:
  305.  *    None.
  306.  *
  307.  *----------------------------------------------------------------------
  308.  */
  309.  
  310. void
  311. TclCopyAndCollapse(count, src, dst)
  312.     int count;            /* Total number of characters to copy
  313.                  * from src. */
  314.     register char *src;        /* Copy from here... */
  315.     register char *dst;        /* ... to here. */
  316. {
  317.     register char c;
  318.     int numRead;
  319.  
  320.     for (c = *src; count > 0; src++, c = *src, count--) {
  321.     if (c == '\\') {
  322.         *dst = Tcl_Backslash(src, &numRead);
  323.         dst++;
  324.         src += numRead-1;
  325.         count -= numRead-1;
  326.     } else {
  327.         *dst = c;
  328.         dst++;
  329.     }
  330.     }
  331.     *dst = 0;
  332. }
  333.  
  334. /*
  335.  *----------------------------------------------------------------------
  336.  *
  337.  * Tcl_SplitList --
  338.  *
  339.  *    Splits a list up into its constituent fields.
  340.  *
  341.  * Results
  342.  *    The return value is normally TCL_OK, which means that
  343.  *    the list was successfully split up.  If TCL_ERROR is
  344.  *    returned, it means that "list" didn't have proper list
  345.  *    structure;  interp->result will contain a more detailed
  346.  *    error message.
  347.  *
  348.  *    *argvPtr will be filled in with the address of an array
  349.  *    whose elements point to the elements of list, in order.
  350.  *    *argcPtr will get filled in with the number of valid elements
  351.  *    in the array.  A single block of memory is dynamically allocated
  352.  *    to hold both the argv array and a copy of the list (with
  353.  *    backslashes and braces removed in the standard way).
  354.  *    The caller must eventually free this memory by calling free()
  355.  *    on *argvPtr.  Note:  *argvPtr and *argcPtr are only modified
  356.  *    if the procedure returns normally.
  357.  *
  358.  * Side effects:
  359.  *    Memory is allocated.
  360.  *
  361.  *----------------------------------------------------------------------
  362.  */
  363.  
  364. int
  365. Tcl_SplitList(interp, list, argcPtr, argvPtr)
  366.     Tcl_Interp *interp;        /* Interpreter to use for error reporting. */
  367.     char *list;            /* Pointer to string with list structure. */
  368.     int *argcPtr;        /* Pointer to location to fill in with
  369.                  * the number of elements in the list. */
  370.     char ***argvPtr;        /* Pointer to place to store pointer to array
  371.                  * of pointers to list elements. */
  372. {
  373.     char **argv;
  374.     register char *p;
  375.     int size, i, result, elSize, brace;
  376.     char *element;
  377.  
  378.     /*
  379.      * Figure out how much space to allocate.  There must be enough
  380.      * space for both the array of pointers and also for a copy of
  381.      * the list.  To estimate the number of pointers needed, count
  382.      * the number of space characters in the list.
  383.      */
  384.  
  385.     for (size = 1, p = list; *p != 0; p++) {
  386.     if (isspace(UCHAR(*p))) {
  387.         size++;
  388.     }
  389.     }
  390.     size++;            /* Leave space for final NULL pointer. */
  391.     argv = (char **) ckalloc((unsigned)
  392.         ((size * sizeof(char *)) + (p - list) + 1));
  393.     for (i = 0, p = ((char *) argv) + size*sizeof(char *);
  394.         *list != 0; i++) {
  395.     result = TclFindElement(interp, list, &element, &list, &elSize, &brace);
  396.     if (result != TCL_OK) {
  397.         ckfree((char *) argv);
  398.         return result;
  399.     }
  400.     if (*element == 0) {
  401.         break;
  402.     }
  403.     if (i >= size) {
  404.         ckfree((char *) argv);
  405.         Tcl_SetResult(interp, "internal error in Tcl_SplitList",
  406.             TCL_STATIC);
  407.         return TCL_ERROR;
  408.     }
  409.     argv[i] = p;
  410.     if (brace) {
  411.         strncpy(p, element, elSize);
  412.         p += elSize;
  413.         *p = 0;
  414.         p++;
  415.     } else {
  416.         TclCopyAndCollapse(elSize, element, p);
  417.         p += elSize+1;
  418.     }
  419.     }
  420.  
  421.     argv[i] = NULL;
  422.     *argvPtr = argv;
  423.     *argcPtr = i;
  424.     return TCL_OK;
  425. }
  426.  
  427. /*
  428.  *----------------------------------------------------------------------
  429.  *
  430.  * Tcl_ScanElement --
  431.  *
  432.  *    This procedure is a companion procedure to Tcl_ConvertElement.
  433.  *    It scans a string to see what needs to be done to it (e.g.
  434.  *    add backslashes or enclosing braces) to make the string into
  435.  *    a valid Tcl list element.
  436.  *
  437.  * Results:
  438.  *    The return value is an overestimate of the number of characters
  439.  *    that will be needed by Tcl_ConvertElement to produce a valid
  440.  *    list element from string.  The word at *flagPtr is filled in
  441.  *    with a value needed by Tcl_ConvertElement when doing the actual
  442.  *    conversion.
  443.  *
  444.  * Side effects:
  445.  *    None.
  446.  *
  447.  *----------------------------------------------------------------------
  448.  */
  449.  
  450. int
  451. Tcl_ScanElement(string, flagPtr)
  452.     char *string;        /* String to convert to Tcl list element. */
  453.     int *flagPtr;        /* Where to store information to guide
  454.                  * Tcl_ConvertElement. */
  455. {
  456.     int flags, nestingLevel;
  457.     register char *p;
  458.  
  459.     /*
  460.      * This procedure and Tcl_ConvertElement together do two things:
  461.      *
  462.      * 1. They produce a proper list, one that will yield back the
  463.      * argument strings when evaluated or when disassembled with
  464.      * Tcl_SplitList.  This is the most important thing.
  465.      * 
  466.      * 2. They try to produce legible output, which means minimizing the
  467.      * use of backslashes (using braces instead).  However, there are
  468.      * some situations where backslashes must be used (e.g. an element
  469.      * like "{abc": the leading brace will have to be backslashed.  For
  470.      * each element, one of three things must be done:
  471.      *
  472.      * (a) Use the element as-is (it doesn't contain anything special
  473.      * characters).  This is the most desirable option.
  474.      *
  475.      * (b) Enclose the element in braces, but leave the contents alone.
  476.      * This happens if the element contains embedded space, or if it
  477.      * contains characters with special interpretation ($, [, ;, or \),
  478.      * or if it starts with a brace or double-quote, or if there are
  479.      * no characters in the element.
  480.      *
  481.      * (c) Don't enclose the element in braces, but add backslashes to
  482.      * prevent special interpretation of special characters.  This is a
  483.      * last resort used when the argument would normally fall under case
  484.      * (b) but contains unmatched braces.  It also occurs if the last
  485.      * character of the argument is a backslash or if the element contains
  486.      * a backslash followed by newline.
  487.      *
  488.      * The procedure figures out how many bytes will be needed to store
  489.      * the result (actually, it overestimates).  It also collects information
  490.      * about the element in the form of a flags word.
  491.      */
  492.  
  493.     nestingLevel = 0;
  494.     flags = 0;
  495.     if (string == NULL) {
  496.     string = "";
  497.     }
  498.     p = string;
  499.     if ((*p == '{') || (*p == '"') || (*p == 0)) {
  500.     flags |= USE_BRACES;
  501.     }
  502.     for ( ; *p != 0; p++) {
  503.     switch (*p) {
  504.         case '{':
  505.         nestingLevel++;
  506.         break;
  507.         case '}':
  508.         nestingLevel--;
  509.         if (nestingLevel < 0) {
  510.             flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED;
  511.         }
  512.         break;
  513.         case '[':
  514.         case '$':
  515.         case ';':
  516.         case ' ':
  517.         case '\f':
  518.         case '\n':
  519.         case '\r':
  520.         case '\t':
  521.         case '\v':
  522.         flags |= USE_BRACES;
  523.         break;
  524.         case '\\':
  525. #if defined(THINK_C) && defined(TCLAPPL)
  526.         if ((p[1] == 0) || (p[1] == '\r')) {
  527. #else
  528.         if ((p[1] == 0) || (p[1] == '\n')) {
  529. #endif
  530.             flags = TCL_DONT_USE_BRACES;
  531.         } else {
  532.             int size;
  533.  
  534.             (void) Tcl_Backslash(p, &size);
  535.             p += size-1;
  536.             flags |= USE_BRACES;
  537.         }
  538.         break;
  539.     }
  540.     }
  541.     if (nestingLevel != 0) {
  542.     flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
  543.     }
  544.     *flagPtr = flags;
  545.  
  546.     /*
  547.      * Allow enough space to backslash every character plus leave
  548.      * two spaces for braces.
  549.      */
  550.  
  551.     return 2*(p-string) + 2;
  552. }
  553.  
  554. /*
  555.  *----------------------------------------------------------------------
  556.  *
  557.  * Tcl_ConvertElement --
  558.  *
  559.  *    This is a companion procedure to Tcl_ScanElement.  Given the
  560.  *    information produced by Tcl_ScanElement, this procedure converts
  561.  *    a string to a list element equal to that string.
  562.  *
  563.  * Results:
  564.  *    Information is copied to *dst in the form of a list element
  565.  *    identical to src (i.e. if Tcl_SplitList is applied to dst it
  566.  *    will produce a string identical to src).  The return value is
  567.  *    a count of the number of characters copied (not including the
  568.  *    terminating NULL character).
  569.  *
  570.  * Side effects:
  571.  *    None.
  572.  *
  573.  *----------------------------------------------------------------------
  574.  */
  575.  
  576. int
  577. Tcl_ConvertElement(src, dst, flags)
  578.     register char *src;        /* Source information for list element. */
  579.     char *dst;            /* Place to put list-ified element. */
  580.     int flags;            /* Flags produced by Tcl_ScanElement. */
  581. {
  582.     register char *p = dst;
  583.  
  584.     /*
  585.      * See the comment block at the beginning of the Tcl_ScanElement
  586.      * code for details of how this works.
  587.      */
  588.  
  589.     if (src == NULL) {
  590.     src = "";
  591.     }
  592.     if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) {
  593.     *p = '{';
  594.     p++;
  595.     for ( ; *src != 0; src++, p++) {
  596.         *p = *src;
  597.     }
  598.     *p = '}';
  599.     p++;
  600.     } else if (*src == 0) {
  601.     /*
  602.      * If string is empty but can't use braces, then use special
  603.      * backslash sequence that maps to empty string.
  604.      */
  605.  
  606.     p[0] = '\\';
  607.     p[1] = '0';
  608.     p += 2;
  609.     } else {
  610.     for (; *src != 0 ; src++) {
  611.         switch (*src) {
  612.         case ']':
  613.         case '[':
  614.         case '$':
  615.         case ';':
  616.         case ' ':
  617.         case '\\':
  618.         case '"':
  619.             *p = '\\';
  620.             p++;
  621.             break;
  622.         case '{':
  623.         case '}':
  624.             if (flags & BRACES_UNMATCHED) {
  625.             *p = '\\';
  626.             p++;
  627.             }
  628.             break;
  629.         case '\f':
  630.             *p = '\\';
  631.             p++;
  632.             *p = 'f';
  633.             p++;
  634.             continue;
  635.         case '\n':
  636.             *p = '\\';
  637.             p++;
  638. #if defined(THINK_C) && defined(TCLAPPL)
  639.             *p = 'r';
  640. #else
  641.             *p = 'n';
  642. #endif
  643.             p++;
  644.             continue;
  645.         case '\r':
  646.             *p = '\\';
  647.             p++;
  648. #if defined(THINK_C) && defined(TCLAPPL)
  649.             *p = 'n';
  650. #else
  651.             *p = 'r';
  652. #endif
  653.             p++;
  654.             continue;
  655.         case '\t':
  656.             *p = '\\';
  657.             p++;
  658.             *p = 't';
  659.             p++;
  660.             continue;
  661.         case '\v':
  662.             *p = '\\';
  663.             p++;
  664.             *p = 'v';
  665.             p++;
  666.             continue;
  667.         }
  668.         *p = *src;
  669.         p++;
  670.     }
  671.     }
  672.     *p = '\0';
  673.     return p-dst;
  674. }
  675.  
  676. /*
  677.  *----------------------------------------------------------------------
  678.  *
  679.  * Tcl_Merge --
  680.  *
  681.  *    Given a collection of strings, merge them together into a
  682.  *    single string that has proper Tcl list structured (i.e.
  683.  *    Tcl_SplitList may be used to retrieve strings equal to the
  684.  *    original elements, and Tcl_Eval will parse the string back
  685.  *    into its original elements).
  686.  *
  687.  * Results:
  688.  *    The return value is the address of a dynamically-allocated
  689.  *    string containing the merged list.
  690.  *
  691.  * Side effects:
  692.  *    None.
  693.  *
  694.  *----------------------------------------------------------------------
  695.  */
  696.  
  697. char *
  698. Tcl_Merge(argc, argv)
  699.     int argc;            /* How many strings to merge. */
  700.     char **argv;        /* Array of string values. */
  701. {
  702. #   define LOCAL_SIZE 20
  703.     int localFlags[LOCAL_SIZE], *flagPtr;
  704.     int numChars;
  705.     char *result;
  706.     register char *dst;
  707.     int i;
  708.  
  709.     /*
  710.      * Pass 1: estimate space, gather flags.
  711.      */
  712.  
  713.     if (argc <= LOCAL_SIZE) {
  714.     flagPtr = localFlags;
  715.     } else {
  716.     flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int));
  717.     }
  718.     numChars = 1;
  719.     for (i = 0; i < argc; i++) {
  720.     numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1;
  721.     }
  722.  
  723.     /*
  724.      * Pass two: copy into the result area.
  725.      */
  726.  
  727.     result = (char *) ckalloc((unsigned) numChars);
  728.     dst = result;
  729.     for (i = 0; i < argc; i++) {
  730.     numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]);
  731.     dst += numChars;
  732.     *dst = ' ';
  733.     dst++;
  734.     }
  735.     if (dst == result) {
  736.     *dst = 0;
  737.     } else {
  738.     dst[-1] = 0;
  739.     }
  740.  
  741.     if (flagPtr != localFlags) {
  742.     ckfree((char *) flagPtr);
  743.     }
  744.     return result;
  745. }
  746.  
  747. /*
  748.  *----------------------------------------------------------------------
  749.  *
  750.  * Tcl_Concat --
  751.  *
  752.  *    Concatenate a set of strings into a single large string.
  753.  *
  754.  * Results:
  755.  *    The return value is dynamically-allocated string containing
  756.  *    a concatenation of all the strings in argv, with spaces between
  757.  *    the original argv elements.
  758.  *
  759.  * Side effects:
  760.  *    Memory is allocated for the result;  the caller is responsible
  761.  *    for freeing the memory.
  762.  *
  763.  *----------------------------------------------------------------------
  764.  */
  765.  
  766. char *
  767. Tcl_Concat(argc, argv)
  768.     int argc;            /* Number of strings to concatenate. */
  769.     char **argv;        /* Array of strings to concatenate. */
  770. {
  771.     int totalSize, i;
  772.     register char *p;
  773.     char *result;
  774.  
  775.     for (totalSize = 1, i = 0; i < argc; i++) {
  776.     totalSize += strlen(argv[i]) + 1;
  777.     }
  778.     result = (char *) ckalloc((unsigned) totalSize);
  779.     if (argc == 0) {
  780.     *result = '\0';
  781.     return result;
  782.     }
  783.     for (p = result, i = 0; i < argc; i++) {
  784.     char *element;
  785.     int length;
  786.  
  787.     /*
  788.      * Clip white space off the front and back of the string
  789.      * to generate a neater result, and ignore any empty
  790.      * elements.
  791.      */
  792.  
  793.     element = argv[i];
  794.     while (isspace(UCHAR(*element))) {
  795.         element++;
  796.     }
  797.     for (length = strlen(element);
  798.         (length > 0) && (isspace(UCHAR(element[length-1])));
  799.         length--) {
  800.         /* Null loop body. */
  801.     }
  802.     if (length == 0) {
  803.         continue;
  804.     }
  805.     (void) strncpy(p, element, length);
  806.     p += length;
  807.     *p = ' ';
  808.     p++;
  809.     }
  810.     if (p != result) {
  811.     p[-1] = 0;
  812.     } else {
  813.     *p = 0;
  814.     }
  815.     return result;
  816. }
  817.  
  818. /*
  819.  *----------------------------------------------------------------------
  820.  *
  821.  * Tcl_StringMatch --
  822.  *
  823.  *    See if a particular string matches a particular pattern.
  824.  *
  825.  * Results:
  826.  *    The return value is 1 if string matches pattern, and
  827.  *    0 otherwise.  The matching operation permits the following
  828.  *    special characters in the pattern: *?\[] (see the manual
  829.  *    entry for details on what these mean).
  830.  *
  831.  * Side effects:
  832.  *    None.
  833.  *
  834.  *----------------------------------------------------------------------
  835.  */
  836.  
  837. #ifdef macintosh
  838. static int        _tcl_string_match_nocase_ = 0;
  839.  
  840. int
  841. Tcl_StringMatchNoCase(string, pattern)
  842.     char *string;    /* String. */
  843.     char *pattern;    /* Pattern, which may contain
  844.                     ** special characters.
  845.                     */
  846.     {
  847.     int        result;
  848.     
  849.     _tcl_string_match_nocase_ = 1;
  850.     result = Tcl_StringMatch(string, pattern);
  851.     _tcl_string_match_nocase_ = 0;
  852.     
  853.     return result;
  854.     }
  855.  
  856. #endif
  857.  
  858.  
  859. int
  860. Tcl_StringMatch(string, pattern)
  861.     register char *string;    /* String. */
  862.     register char *pattern;    /* Pattern, which may contain
  863.                  * special characters. */
  864. {
  865.     char c2;
  866.  
  867.     while (1) {
  868.     /* See if we're at the end of both the pattern and the string.
  869.      * If so, we succeeded.  If we're at the end of the pattern
  870.      * but not at the end of the string, we failed.
  871.      */
  872.     
  873.     if (*pattern == 0) {
  874.         if (*string == 0) {
  875.         return 1;
  876.         } else {
  877.         return 0;
  878.         }
  879.     }
  880.     if ((*string == 0) && (*pattern != '*')) {
  881.         return 0;
  882.     }
  883.  
  884.     /* Check for a "*" as the next pattern character.  It matches
  885.      * any substring.  We handle this by calling ourselves
  886.      * recursively for each postfix of string, until either we
  887.      * match or we reach the end of the string.
  888.      */
  889.     
  890.     if (*pattern == '*') {
  891.         pattern += 1;
  892.         if (*pattern == 0) {
  893.         return 1;
  894.         }
  895.         while (1) {
  896.         if (Tcl_StringMatch(string, pattern)) {
  897.             return 1;
  898.         }
  899.         if (*string == 0) {
  900.             return 0;
  901.         }
  902.         string += 1;
  903.         }
  904.     }
  905.     
  906.     /* Check for a "?" as the next pattern character.  It matches
  907.      * any single character.
  908.      */
  909.  
  910.     if (*pattern == '?') {
  911.         goto thisCharOK;
  912.     }
  913.  
  914.     /* Check for a "[" as the next pattern character.  It is followed
  915.      * by a list of characters that are acceptable, or by a range
  916.      * (two characters separated by "-").
  917.      */
  918.     
  919.     if (*pattern == '[') {
  920.         pattern += 1;
  921.         while (1) {
  922.         if ((*pattern == ']') || (*pattern == 0)) {
  923.             return 0;
  924.         }
  925.         if (*pattern == *string) {
  926.             break;
  927.         }
  928.         if (pattern[1] == '-') {
  929.             c2 = pattern[2];
  930.             if (c2 == 0) {
  931.             return 0;
  932.             }
  933.             if ((*pattern <= *string) && (c2 >= *string)) {
  934.             break;
  935.             }
  936.             if ((*pattern >= *string) && (c2 <= *string)) {
  937.             break;
  938.             }
  939.             pattern += 2;
  940.         }
  941.         pattern += 1;
  942.         }
  943.         while ((*pattern != ']') && (*pattern != 0)) {
  944.         pattern += 1;
  945.         }
  946.         goto thisCharOK;
  947.     }
  948.     
  949.     /* If the next pattern character is '\', just strip off the '\'
  950.      * so we do exact matching on the character that follows.
  951.      */
  952.     
  953.     if (*pattern == '\\') {
  954.         pattern += 1;
  955.         if (*pattern == 0) {
  956.         return 0;
  957.         }
  958.     }
  959.  
  960.     /* There's no special character.  Just make sure that the next
  961.      * characters of each string match.
  962.      */
  963.  
  964. #ifdef macintosh
  965.     if (_tcl_string_match_nocase_)
  966.         {
  967.         int    ch1, ch2;
  968.         
  969.         ch1 = *pattern;
  970.         ch2 = *string;
  971.         
  972.         if ( ch1 >= 'A' && ch1 <= 'Z' )
  973.             ch1 += 0x20; /* make lower case */
  974.         if ( ch2 >= 'A' && ch2 <= 'Z' )
  975.             ch2 += 0x20; /* make lower case */
  976.         
  977.         if (ch1 != ch2)
  978.             return 0;
  979.         }
  980.     else if ( *pattern != *string )
  981.         return 0;
  982. #else
  983.     if (*pattern != *string) {
  984.         return 0;
  985.     }
  986. #endif
  987.  
  988. thisCharOK:
  989.     pattern += 1;
  990.     string += 1;
  991.     }
  992. }
  993.  
  994. /*
  995.  *----------------------------------------------------------------------
  996.  *
  997.  * Tcl_SetResult --
  998.  *
  999.  *    Arrange for "string" to be the Tcl return value.
  1000.  *
  1001.  * Results:
  1002.  *    None.
  1003.  *
  1004.  * Side effects:
  1005.  *    interp->result is left pointing either to "string" (if "copy" is 0)
  1006.  *    or to a copy of string.
  1007.  *
  1008.  *----------------------------------------------------------------------
  1009.  */
  1010.  
  1011. void
  1012. Tcl_SetResult(interp, string, freeProc)
  1013.     Tcl_Interp *interp;        /* Interpreter with which to associate the
  1014.                  * return value. */
  1015.     char *string;        /* Value to be returned.  If NULL,
  1016.                  * the result is set to an empty string. */
  1017.     Tcl_FreeProc *freeProc;    /* Gives information about the string:
  1018.                  * TCL_STATIC, TCL_VOLATILE, or the address
  1019.                  * of a Tcl_FreeProc such as free. */
  1020. {
  1021.     register Interp *iPtr = (Interp *) interp;
  1022.     int length;
  1023.     Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
  1024.     char *oldResult = iPtr->result;
  1025.  
  1026.     iPtr->freeProc = freeProc;
  1027.     if (string == NULL) {
  1028.     iPtr->resultSpace[0] = 0;
  1029.     iPtr->result = iPtr->resultSpace;
  1030.     iPtr->freeProc = 0;
  1031.     } else if (freeProc == TCL_VOLATILE) {
  1032.     length = strlen(string);
  1033.     if (length > TCL_RESULT_SIZE) {
  1034.         iPtr->result = (char *) ckalloc((unsigned) length+1);
  1035.         iPtr->freeProc = (Tcl_FreeProc *) free;
  1036.     } else {
  1037.         iPtr->result = iPtr->resultSpace;
  1038.         iPtr->freeProc = 0;
  1039.     }
  1040.     strcpy(iPtr->result, string);
  1041.     } else {
  1042.     iPtr->result = string;
  1043.     }
  1044.  
  1045.     /*
  1046.      * If the old result was dynamically-allocated, free it up.  Do it
  1047.      * here, rather than at the beginning, in case the new result value
  1048.      * was part of the old result value.
  1049.      */
  1050.  
  1051.     if (oldFreeProc != 0) {
  1052.     if (oldFreeProc == (Tcl_FreeProc *) free) {
  1053.         ckfree(oldResult);
  1054.     } else {
  1055.         (*oldFreeProc)(oldResult);
  1056.     }
  1057.     }
  1058. }
  1059.  
  1060. /*
  1061.  *----------------------------------------------------------------------
  1062.  *
  1063.  * Tcl_AppendResult --
  1064.  *
  1065.  *    Append a variable number of strings onto the result already
  1066.  *    present for an interpreter.
  1067.  *
  1068.  * Results:
  1069.  *    None.
  1070.  *
  1071.  * Side effects:
  1072.  *    The result in the interpreter given by the first argument
  1073.  *    is extended by the strings given by the second and following
  1074.  *    arguments (up to a terminating NULL argument).
  1075.  *
  1076.  *----------------------------------------------------------------------
  1077.  */
  1078.  
  1079.     /* VARARGS2 */
  1080. #ifdef macintosh
  1081.  
  1082. void
  1083. Tcl_AppendResult(Tcl_Interp *interp, ...)
  1084. {
  1085.  
  1086. #else
  1087.  
  1088. #ifndef lint
  1089. void
  1090. Tcl_AppendResult(va_alist)
  1091. #else
  1092. void
  1093.     /* VARARGS2 */ /* ARGSUSED */
  1094. Tcl_AppendResult(interp, p, va_alist)
  1095.     Tcl_Interp *interp;        /* Interpreter whose result is to be
  1096.                  * extended. */
  1097.     char *p;            /* One or more strings to add to the
  1098.                  * result, terminated with NULL. */
  1099. #endif
  1100.     va_dcl
  1101. {
  1102.  
  1103. #endif
  1104.  
  1105.     va_list argList;
  1106.     register Interp *iPtr;
  1107.     char *string;
  1108.     int newSpace;
  1109.  
  1110.     /*
  1111.      * First, scan through all the arguments to see how much space is
  1112.      * needed.
  1113.      */
  1114.  
  1115. #ifdef macintosh
  1116.     va_start(argList, interp);
  1117. #else
  1118.     va_start(argList);
  1119. #endif
  1120.  
  1121. #ifdef macintosh
  1122.     iPtr = (Interp *) interp;
  1123. #else
  1124.     iPtr = va_arg(argList, Interp *);
  1125. #endif
  1126.  
  1127.     newSpace = 0;
  1128.     while (1) {
  1129.     string = va_arg(argList, char *);
  1130.     if (string == NULL) {
  1131.         break;
  1132.     }
  1133.     newSpace += strlen(string);
  1134.     }
  1135.     va_end(argList);
  1136.  
  1137.     /*
  1138.      * If the append buffer isn't already setup and large enough
  1139.      * to hold the new data, set it up.
  1140.      */
  1141.  
  1142.     if ((iPtr->result != iPtr->appendResult)
  1143.         || (iPtr->appendResult[iPtr->appendUsed] != 0)
  1144.         || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
  1145.        SetupAppendBuffer(iPtr, newSpace);
  1146.     }
  1147.  
  1148.     /*
  1149.      * Final step:  go through all the argument strings again, copying
  1150.      * them into the buffer.
  1151.      */
  1152.  
  1153. #ifdef macintosh
  1154.     va_start(argList, interp);
  1155. #else
  1156.     va_start(argList);
  1157.     (void) va_arg(argList, Tcl_Interp *);
  1158. #endif
  1159.  
  1160.     while (1) {
  1161.     string = va_arg(argList, char *);
  1162.     if (string == NULL) {
  1163.         break;
  1164.     }
  1165.     strcpy(iPtr->appendResult + iPtr->appendUsed, string);
  1166.     iPtr->appendUsed += strlen(string);
  1167.     }
  1168.     va_end(argList);
  1169. }
  1170.  
  1171. /*
  1172.  *----------------------------------------------------------------------
  1173.  *
  1174.  * Tcl_AppendElement --
  1175.  *
  1176.  *    Convert a string to a valid Tcl list element and append it
  1177.  *    to the current result (which is ostensibly a list).
  1178.  *
  1179.  * Results:
  1180.  *    None.
  1181.  *
  1182.  * Side effects:
  1183.  *    The result in the interpreter given by the first argument
  1184.  *    is extended with a list element converted from string.  A
  1185.  *    separator space is added before the converted list element
  1186.  *    unless the current result is empty, contains the single
  1187.  *    character "{", or ends in " {".
  1188.  *
  1189.  *----------------------------------------------------------------------
  1190.  */
  1191.  
  1192. void
  1193. Tcl_AppendElement(interp, string)
  1194.     Tcl_Interp *interp;        /* Interpreter whose result is to be
  1195.                  * extended. */
  1196.     char *string;        /* String to convert to list element and
  1197.                  * add to result. */
  1198. {
  1199.     register Interp *iPtr = (Interp *) interp;
  1200.     int size, flags;
  1201.     char *dst;
  1202.  
  1203.     /*
  1204.      * See how much space is needed, and grow the append buffer if
  1205.      * needed to accommodate the list element.
  1206.      */
  1207.  
  1208.     size = Tcl_ScanElement(string, &flags) + 1;
  1209.     if ((iPtr->result != iPtr->appendResult)
  1210.         || (iPtr->appendResult[iPtr->appendUsed] != 0)
  1211.         || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
  1212.        SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
  1213.     }
  1214.  
  1215.     /*
  1216.      * Convert the string into a list element and copy it to the
  1217.      * buffer that's forming.
  1218.      */
  1219.  
  1220.     dst = iPtr->appendResult + iPtr->appendUsed;
  1221.     if ((iPtr->appendUsed > 0) && ((dst[-1] != '{')
  1222.         || ((iPtr->appendUsed > 1) && (dst[-2] == '\\')))) {
  1223.     iPtr->appendUsed++;
  1224.     *dst = ' ';
  1225.     dst++;
  1226.     }
  1227.     iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);
  1228. }
  1229.  
  1230. /*
  1231.  *----------------------------------------------------------------------
  1232.  *
  1233.  * SetupAppendBuffer --
  1234.  *
  1235.  *    This procedure makes sure that there is an append buffer
  1236.  *    properly initialized for interp, and that it has at least
  1237.  *    enough room to accommodate newSpace new bytes of information.
  1238.  *
  1239.  * Results:
  1240.  *    None.
  1241.  *
  1242.  * Side effects:
  1243.  *    None.
  1244.  *
  1245.  *----------------------------------------------------------------------
  1246.  */
  1247.  
  1248. static void
  1249. SetupAppendBuffer(iPtr, newSpace)
  1250.     register Interp *iPtr;    /* Interpreter whose result is being set up. */
  1251.     int newSpace;        /* Make sure that at least this many bytes
  1252.                  * of new information may be added. */
  1253. {
  1254.     int totalSpace;
  1255.  
  1256.     /*
  1257.      * Make the append buffer larger, if that's necessary, then
  1258.      * copy the current result into the append buffer and make the
  1259.      * append buffer the official Tcl result.
  1260.      */
  1261.  
  1262.     if (iPtr->result != iPtr->appendResult) {
  1263.     /*
  1264.      * If an oversized buffer was used recently, then free it up
  1265.      * so we go back to a smaller buffer.  This avoids tying up
  1266.      * memory forever after a large operation.
  1267.      */
  1268.  
  1269.     if (iPtr->appendAvl > 500) {
  1270.         ckfree(iPtr->appendResult);
  1271.         iPtr->appendResult = NULL;
  1272.         iPtr->appendAvl = 0;
  1273.     }
  1274.     iPtr->appendUsed = strlen(iPtr->result);
  1275.     } else if (iPtr->result[iPtr->appendUsed] != 0) {
  1276.     /*
  1277.      * Most likely someone has modified a result created by
  1278.      * Tcl_AppendResult et al. so that it has a different size.
  1279.      * Just recompute the size.
  1280.      */
  1281.  
  1282.     iPtr->appendUsed = strlen(iPtr->result);
  1283.     }
  1284.     totalSpace = newSpace + iPtr->appendUsed;
  1285.     if (totalSpace >= iPtr->appendAvl) {
  1286.     char *new;
  1287.  
  1288.     if (totalSpace < 100) {
  1289.         totalSpace = 200;
  1290.     } else {
  1291.         totalSpace *= 2;
  1292.     }
  1293.     new = (char *) ckalloc((unsigned) totalSpace);
  1294.     strcpy(new, iPtr->result);
  1295.     if (iPtr->appendResult != NULL) {
  1296.         ckfree(iPtr->appendResult);
  1297.     }
  1298.     iPtr->appendResult = new;
  1299.     iPtr->appendAvl = totalSpace;
  1300.     } else if (iPtr->result != iPtr->appendResult) {
  1301.     strcpy(iPtr->appendResult, iPtr->result);
  1302.     }
  1303.     Tcl_FreeResult(iPtr);
  1304.     iPtr->result = iPtr->appendResult;
  1305. }
  1306.  
  1307. /*
  1308.  *----------------------------------------------------------------------
  1309.  *
  1310.  * Tcl_ResetResult --
  1311.  *
  1312.  *    This procedure restores the result area for an interpreter
  1313.  *    to its default initialized state, freeing up any memory that
  1314.  *    may have been allocated for the result and clearing any
  1315.  *    error information for the interpreter.
  1316.  *
  1317.  * Results:
  1318.  *    None.
  1319.  *
  1320.  * Side effects:
  1321.  *    None.
  1322.  *
  1323.  *----------------------------------------------------------------------
  1324.  */
  1325.  
  1326. void
  1327. Tcl_ResetResult(interp)
  1328.     Tcl_Interp *interp;        /* Interpreter for which to clear result. */
  1329. {
  1330.     register Interp *iPtr = (Interp *) interp;
  1331.  
  1332.     Tcl_FreeResult(iPtr);
  1333.     iPtr->result = iPtr->resultSpace;
  1334.     iPtr->resultSpace[0] = 0;
  1335.     iPtr->flags &=
  1336.         ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
  1337. }
  1338.  
  1339. /*
  1340.  *----------------------------------------------------------------------
  1341.  *
  1342.  * Tcl_SetErrorCode --
  1343.  *
  1344.  *    This procedure is called to record machine-readable information
  1345.  *    about an error that is about to be returned.
  1346.  *
  1347.  * Results:
  1348.  *    None.
  1349.  *
  1350.  * Side effects:
  1351.  *    The errorCode global variable is modified to hold all of the
  1352.  *    arguments to this procedure, in a list form with each argument
  1353.  *    becoming one element of the list.  A flag is set internally
  1354.  *    to remember that errorCode has been set, so the variable doesn't
  1355.  *    get set automatically when the error is returned.
  1356.  *
  1357.  *----------------------------------------------------------------------
  1358.  */
  1359.     /* VARARGS2 */
  1360. #ifdef macintosh
  1361.  
  1362. void
  1363. Tcl_SetErrorCode(Tcl_Interp *interp, ...)
  1364.  
  1365. #else
  1366.  
  1367. #ifndef lint
  1368. void
  1369. Tcl_SetErrorCode(va_alist)
  1370. #else
  1371. void
  1372.     /* VARARGS2 */ /* ARGSUSED */
  1373. Tcl_SetErrorCode(interp, p, va_alist)
  1374.     Tcl_Interp *interp;        /* Interpreter whose errorCode variable is
  1375.                  * to be set. */
  1376.     char *p;            /* One or more elements to add to errorCode,
  1377.                  * terminated with NULL. */
  1378. #endif
  1379.     va_dcl
  1380.  
  1381. #endif
  1382.  
  1383. {
  1384.     va_list argList;
  1385.     char *string;
  1386.     int flags;
  1387.     Interp *iPtr;
  1388.  
  1389.     /*
  1390.      * Scan through the arguments one at a time, appending them to
  1391.      * $errorCode as list elements.
  1392.      */
  1393.  
  1394. #ifdef macintosh
  1395.     va_start(argList, interp);
  1396. #else
  1397.     va_start(argList);
  1398. #endif
  1399.  
  1400. #ifdef macintosh
  1401.     iPtr = (Interp *) interp;
  1402. #else
  1403.     iPtr = va_arg(argList, Interp *);
  1404. #endif
  1405.  
  1406.     flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
  1407.     while (1) {
  1408.     string = va_arg(argList, char *);
  1409.     if (string == NULL) {
  1410.         break;
  1411.     }
  1412.     (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
  1413.         (char *) NULL, string, flags);
  1414.     flags |= TCL_APPEND_VALUE;
  1415.     }
  1416.     va_end(argList);
  1417.     iPtr->flags |= ERROR_CODE_SET;
  1418. }
  1419.  
  1420. /*
  1421.  *----------------------------------------------------------------------
  1422.  *
  1423.  * TclGetListIndex --
  1424.  *
  1425.  *    Parse a list index, which may be either an integer or the
  1426.  *    value "end".
  1427.  *
  1428.  * Results:
  1429.  *    The return value is either TCL_OK or TCL_ERROR.  If it is
  1430.  *    TCL_OK, then the index corresponding to string is left in
  1431.  *    *indexPtr.  If the return value is TCL_ERROR, then string
  1432.  *    was bogus;  an error message is returned in interp->result.
  1433.  *    If a negative index is specified, it is rounded up to 0.
  1434.  *    The index value may be larger than the size of the list
  1435.  *    (this happens when "end" is specified).
  1436.  *
  1437.  * Side effects:
  1438.  *    None.
  1439.  *
  1440.  *----------------------------------------------------------------------
  1441.  */
  1442.  
  1443. int
  1444. TclGetListIndex(interp, string, indexPtr)
  1445.     Tcl_Interp *interp;            /* Interpreter for error reporting. */
  1446.     char *string;            /* String containing list index. */
  1447.     int *indexPtr;            /* Where to store index. */
  1448. {
  1449.     if (isdigit(UCHAR(*string)) || (*string == '-')) {
  1450.     if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) {
  1451.         return TCL_ERROR;
  1452.     }
  1453.     if (*indexPtr < 0) {
  1454.         *indexPtr = 0;
  1455.     }
  1456.     } else if (strncmp(string, "end", strlen(string)) == 0) {
  1457.     *indexPtr = 1<<30;
  1458.     } else {
  1459.     Tcl_AppendResult(interp, "bad index \"", string,
  1460.         "\": must be integer or \"end\"", (char *) NULL);
  1461.     return TCL_ERROR;
  1462.     }
  1463.     return TCL_OK;
  1464. }
  1465.  
  1466. /*
  1467.  *----------------------------------------------------------------------
  1468.  *
  1469.  * TclCompileRegexp --
  1470.  *
  1471.  *    Compile a regular expression into a form suitable for fast
  1472.  *    matching.  This procedure retains a small cache of pre-compiled
  1473.  *    regular expressions in the interpreter, in order to avoid
  1474.  *    compilation costs as much as possible.
  1475.  *
  1476.  * Results:
  1477.  *    The return value is a pointer to the compiled form of string,
  1478.  *    suitable for passing to TclRegExec.  If an error occurred while
  1479.  *    compiling the pattern, then NULL is returned and an error
  1480.  *    message is left in interp->result.
  1481.  *
  1482.  * Side effects:
  1483.  *    The cache of compiled regexp's in interp will be modified to
  1484.  *    hold information for string, if such information isn't already
  1485.  *    present in the cache.
  1486.  *
  1487.  *----------------------------------------------------------------------
  1488.  */
  1489.  
  1490. regexp *
  1491. TclCompileRegexp(interp, string)
  1492.     Tcl_Interp *interp;            /* For use in error reporting. */
  1493.     char *string;            /* String for which to produce
  1494.                      * compiled regular expression. */
  1495. {
  1496.     register Interp *iPtr = (Interp *) interp;
  1497.     int i, length;
  1498.     regexp *result;
  1499.  
  1500.     length = strlen(string);
  1501.     for (i = 0; i < NUM_REGEXPS; i++) {
  1502.     if ((length == iPtr->patLengths[i])
  1503.         && (strcmp(string, iPtr->patterns[i]) == 0)) {
  1504.         /*
  1505.          * Move the matched pattern to the first slot in the
  1506.          * cache and shift the other patterns down one position.
  1507.          */
  1508.  
  1509.         if (i != 0) {
  1510.         int j;
  1511.         char *cachedString;
  1512.  
  1513.         cachedString = iPtr->patterns[i];
  1514.         result = iPtr->regexps[i];
  1515.         for (j = i-1; j >= 0; j--) {
  1516.             iPtr->patterns[j+1] = iPtr->patterns[j];
  1517.             iPtr->patLengths[j+1] = iPtr->patLengths[j];
  1518.             iPtr->regexps[j+1] = iPtr->regexps[j];
  1519.         }
  1520.         iPtr->patterns[0] = cachedString;
  1521.         iPtr->patLengths[0] = length;
  1522.         iPtr->regexps[0] = result;
  1523.         }
  1524.         return iPtr->regexps[0];
  1525.     }
  1526.     }
  1527.  
  1528.     /*
  1529.      * No match in the cache.  Compile the string and add it to the
  1530.      * cache.
  1531.      */
  1532.  
  1533.     tclRegexpError = NULL;
  1534.     result = TclRegComp(string);
  1535.     if (tclRegexpError != NULL) {
  1536.     Tcl_AppendResult(interp,
  1537.         "couldn't compile regular expression pattern: ",
  1538.         tclRegexpError, (char *) NULL);
  1539.     return NULL;
  1540.     }
  1541.     if (iPtr->patterns[NUM_REGEXPS-1] != NULL) {
  1542.     ckfree(iPtr->patterns[NUM_REGEXPS-1]);
  1543.     ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]);
  1544.     }
  1545.     for (i = NUM_REGEXPS - 2; i >= 0; i--) {
  1546.     iPtr->patterns[i+1] = iPtr->patterns[i];
  1547.     iPtr->patLengths[i+1] = iPtr->patLengths[i];
  1548.     iPtr->regexps[i+1] = iPtr->regexps[i];
  1549.     }
  1550.     iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1));
  1551.     strcpy(iPtr->patterns[0], string);
  1552.     iPtr->patLengths[0] = length;
  1553.     iPtr->regexps[0] = result;
  1554.     return result;
  1555. }
  1556.  
  1557. /*
  1558.  *----------------------------------------------------------------------
  1559.  *
  1560.  * TclRegError --
  1561.  *
  1562.  *    This procedure is invoked by the Henry Spencer's regexp code
  1563.  *    when an error occurs.  It saves the error message so it can
  1564.  *    be seen by the code that called Spencer's code.
  1565.  *
  1566.  * Results:
  1567.  *    None.
  1568.  *
  1569.  * Side effects:
  1570.  *    The value of "string" is saved in "tclRegexpError".
  1571.  *
  1572.  *----------------------------------------------------------------------
  1573.  */
  1574.  
  1575. void
  1576. TclRegError(string)
  1577.     char *string;            /* Error message. */
  1578. {
  1579.     tclRegexpError = string;
  1580. }
  1581.  
  1582. /*
  1583.  *----------------------------------------------------------------------
  1584.  *
  1585.  * Tcl_RegExpMatch --
  1586.  *
  1587.  *    See if a string matches a regular expression.
  1588.  *
  1589.  * Results:
  1590.  *    If an error occurs during the matching operation then -1
  1591.  *    is returned and interp->result contains an error message.
  1592.  *    Otherwise the return value is 1 if "string" matches "pattern"
  1593.  *    and 0 otherwise.
  1594.  *
  1595.  * Side effects:
  1596.  *    None.
  1597.  *
  1598.  *----------------------------------------------------------------------
  1599.  */
  1600.  
  1601. int
  1602. Tcl_RegExpMatch(interp, string, pattern)
  1603.     Tcl_Interp *interp;        /* Used for error reporting. */
  1604.     char *string;        /* String. */
  1605.     char *pattern;        /* Regular expression to match against
  1606.                  * string. */
  1607. {
  1608.     regexp *regexpPtr;
  1609.     int match;
  1610.  
  1611.     regexpPtr = TclCompileRegexp(interp, pattern);
  1612.     if (regexpPtr == NULL) {
  1613.     return -1;
  1614.     }
  1615.     tclRegexpError = NULL;
  1616.     match = TclRegExec(regexpPtr, string, string);
  1617.     if (tclRegexpError != NULL) {
  1618.     Tcl_ResetResult(interp);
  1619.     Tcl_AppendResult(interp, "error while matching regular expression: ",
  1620.         tclRegexpError, (char *) NULL);
  1621.     return -1;
  1622.     }
  1623.     return match;
  1624. }
  1625.  
  1626. /*
  1627.  *----------------------------------------------------------------------
  1628.  *
  1629.  * Tcl_DStringInit --
  1630.  *
  1631.  *    Initializes a dynamic string, discarding any previous contents
  1632.  *    of the string (Tcl_DStringFree should have been called already
  1633.  *    if the dynamic string was previously in use).
  1634.  *
  1635.  * Results:
  1636.  *    None.
  1637.  *
  1638.  * Side effects:
  1639.  *    The dynamic string is initialized to be empty.
  1640.  *
  1641.  *----------------------------------------------------------------------
  1642.  */
  1643.  
  1644. void
  1645. Tcl_DStringInit(dsPtr)
  1646.     register Tcl_DString *dsPtr;    /* Pointer to structure for
  1647.                      * dynamic string. */
  1648. {
  1649.     dsPtr->string = dsPtr->staticSpace;
  1650.     dsPtr->length = 0;
  1651.     dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
  1652.     dsPtr->staticSpace[0] = 0;
  1653. }
  1654.  
  1655. /*
  1656.  *----------------------------------------------------------------------
  1657.  *
  1658.  * Tcl_DStringAppend --
  1659.  *
  1660.  *    Append more characters to the current value of a dynamic string.
  1661.  *
  1662.  * Results:
  1663.  *    The return value is a pointer to the dynamic string's new value.
  1664.  *
  1665.  * Side effects:
  1666.  *    Length bytes from string (or all of string if length is less
  1667.  *    than zero) are added to the current value of the string.  Memory
  1668.  *    gets reallocated if needed to accomodate the string's new size.
  1669.  *
  1670.  *----------------------------------------------------------------------
  1671.  */
  1672.  
  1673. char *
  1674. Tcl_DStringAppend(dsPtr, string, length)
  1675.     register Tcl_DString *dsPtr;    /* Structure describing dynamic
  1676.                      * string. */
  1677.     char *string;            /* String to append.  If length is
  1678.                      * -1 then this must be
  1679.                      * null-terminated. */
  1680.     int length;                /* Number of characters from string
  1681.                      * to append.  If < 0, then append all
  1682.                      * of string, up to null at end. */
  1683. {
  1684.     int newSize;
  1685.     char *newString;
  1686.  
  1687.     if (length < 0) {
  1688.     length = strlen(string);
  1689.     }
  1690.     newSize = length + dsPtr->length;
  1691.  
  1692.     /*
  1693.      * Allocate a larger buffer for the string if the current one isn't
  1694.      * large enough.  Allocate extra space in the new buffer so that there
  1695.      * will be room to grow before we have to allocate again.
  1696.      */
  1697.  
  1698.     if (newSize >= dsPtr->spaceAvl) {
  1699.     dsPtr->spaceAvl = newSize*2;
  1700.     newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
  1701.     strcpy(newString, dsPtr->string);
  1702.     if (dsPtr->string != dsPtr->staticSpace) {
  1703.         ckfree(dsPtr->string);
  1704.     }
  1705.     dsPtr->string = newString;
  1706.     }
  1707.  
  1708.     /*
  1709.      * Copy the new string into the buffer at the end of the old
  1710.      * one.
  1711.      */
  1712.  
  1713.     strncpy(dsPtr->string + dsPtr->length, string, length);
  1714.     dsPtr->length += length;
  1715.     dsPtr->string[dsPtr->length] = 0;
  1716.     return dsPtr->string;
  1717. }
  1718.  
  1719. /*
  1720.  *----------------------------------------------------------------------
  1721.  *
  1722.  * Tcl_DStringAppendElement --
  1723.  *
  1724.  *    Append a list element to the current value of a dynamic string.
  1725.  *
  1726.  * Results:
  1727.  *    The return value is a pointer to the dynamic string's new value.
  1728.  *
  1729.  * Side effects:
  1730.  *    String is reformatted as a list element and added to the current
  1731.  *    value of the string.  Memory gets reallocated if needed to
  1732.  *    accomodate the string's new size.
  1733.  *
  1734.  *----------------------------------------------------------------------
  1735.  */
  1736.  
  1737. char *
  1738. Tcl_DStringAppendElement(dsPtr, string)
  1739.     register Tcl_DString *dsPtr;    /* Structure describing dynamic
  1740.                      * string. */
  1741.     char *string;            /* String to append.  Must be
  1742.                      * null-terminated. */
  1743. {
  1744.     int newSize, flags;
  1745.     char *dst, *newString;
  1746.  
  1747.     newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1;
  1748.  
  1749.     /*
  1750.      * Allocate a larger buffer for the string if the current one isn't
  1751.      * large enough.  Allocate extra space in the new buffer so that there
  1752.      * will be room to grow before we have to allocate again.
  1753.      */
  1754.  
  1755.     if (newSize >= dsPtr->spaceAvl) {
  1756.     dsPtr->spaceAvl = newSize*2;
  1757.     newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
  1758.     strcpy(newString, dsPtr->string);
  1759.     if (dsPtr->string != dsPtr->staticSpace) {
  1760.         ckfree(dsPtr->string);
  1761.     }
  1762.     dsPtr->string = newString;
  1763.     }
  1764.  
  1765.     /*
  1766.      * Convert the new string to a list element and copy it into the
  1767.      * buffer at the end.  Add a space separator unless we're at the
  1768.      * start of the string or just after an unbackslashed "{".
  1769.      */
  1770.  
  1771.     dst = dsPtr->string + dsPtr->length;
  1772.     if ((dsPtr->length > 0) && ((dst[-1] != '{')
  1773.         || ((dsPtr->length > 1) && (dst[-2] == '\\')))) {
  1774.     *dst = ' ';
  1775.     dst++;
  1776.     dsPtr->length++;
  1777.     }
  1778.     dsPtr->length += Tcl_ConvertElement(string, dst, flags);
  1779.     return dsPtr->string;
  1780. }
  1781.  
  1782. /*
  1783.  *----------------------------------------------------------------------
  1784.  *
  1785.  * Tcl_DStringTrunc --
  1786.  *
  1787.  *    Truncate a dynamic string to a given length without freeing
  1788.  *    up its storage.
  1789.  *
  1790.  * Results:
  1791.  *    None.
  1792.  *
  1793.  * Side effects:
  1794.  *    The length of dsPtr is reduced to length unless it was already
  1795.  *    shorter than that.
  1796.  *
  1797.  *----------------------------------------------------------------------
  1798.  */
  1799.  
  1800. void
  1801. Tcl_DStringTrunc(dsPtr, length)
  1802.     register Tcl_DString *dsPtr;    /* Structure describing dynamic
  1803.                      * string. */
  1804.     int length;                /* New length for dynamic string. */
  1805. {
  1806.     if (length < 0) {
  1807.     length = 0;
  1808.     }
  1809.     if (length < dsPtr->length) {
  1810.     dsPtr->length = length;
  1811.     dsPtr->string[length] = 0;
  1812.     }
  1813. }
  1814.  
  1815. /*
  1816.  *----------------------------------------------------------------------
  1817.  *
  1818.  * Tcl_DStringFree --
  1819.  *
  1820.  *    Frees up any memory allocated for the dynamic string and
  1821.  *    reinitializes the string to an empty state.
  1822.  *
  1823.  * Results:
  1824.  *    None.
  1825.  *
  1826.  * Side effects:
  1827.  *    The previous contents of the dynamic string are lost, and
  1828.  *    the new value is an empty string.
  1829.  *
  1830.  *----------------------------------------------------------------------
  1831.  */
  1832.  
  1833. void
  1834. Tcl_DStringFree(dsPtr)
  1835.     register Tcl_DString *dsPtr;    /* Structure describing dynamic
  1836.                      * string. */
  1837. {
  1838.     if (dsPtr->string != dsPtr->staticSpace) {
  1839.     ckfree(dsPtr->string);
  1840.     }
  1841.     dsPtr->string = dsPtr->staticSpace;
  1842.     dsPtr->length = 0;
  1843.     dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
  1844.     dsPtr->staticSpace[0] = 0;
  1845. }
  1846.  
  1847. /*
  1848.  *----------------------------------------------------------------------
  1849.  *
  1850.  * Tcl_DStringResult --
  1851.  *
  1852.  *    This procedure moves the value of a dynamic string into an
  1853.  *    interpreter as its result.  The string itself is reinitialized
  1854.  *    to an empty string.
  1855.  *
  1856.  * Results:
  1857.  *    None.
  1858.  *
  1859.  * Side effects:
  1860.  *    The string is "moved" to interp's result, and any existing
  1861.  *    result for interp is freed up.  DsPtr is reinitialized to
  1862.  *    an empty string.
  1863.  *
  1864.  *----------------------------------------------------------------------
  1865.  */
  1866.  
  1867. void
  1868. Tcl_DStringResult(interp, dsPtr)
  1869.     Tcl_Interp *interp;            /* Interpreter whose result is to be
  1870.                      * reset. */
  1871.     Tcl_DString *dsPtr;            /* Dynamic string that is to become
  1872.                      * the result of interp. */
  1873. {
  1874.     Tcl_FreeResult(interp);
  1875.     if (dsPtr->string != dsPtr->staticSpace) {
  1876.     interp->result = dsPtr->string;
  1877.     interp->freeProc = (Tcl_FreeProc *) free;
  1878.     } else if (dsPtr->length < TCL_RESULT_SIZE) {
  1879.     strcpy(interp->result, dsPtr->string);
  1880.     } else {
  1881.     Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE);
  1882.     }
  1883.     dsPtr->string = dsPtr->staticSpace;
  1884.     dsPtr->length = 0;
  1885.     dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
  1886.     dsPtr->staticSpace[0] = 0;
  1887. }
  1888.  
  1889. /*
  1890.  *----------------------------------------------------------------------
  1891.  *
  1892.  * Tcl_DStringStartSublist --
  1893.  *
  1894.  *    This procedure adds the necessary information to a dynamic
  1895.  *    string (e.g. " {" to start a sublist.  Future element
  1896.  *    appends will be in the sublist rather than the main list.
  1897.  *
  1898.  * Results:
  1899.  *    None.
  1900.  *
  1901.  * Side effects:
  1902.  *    Characters get added to the dynamic string.
  1903.  *
  1904.  *----------------------------------------------------------------------
  1905.  */
  1906.  
  1907. void
  1908. Tcl_DStringStartSublist(dsPtr)
  1909.     Tcl_DString *dsPtr;            /* Dynamic string. */
  1910. {
  1911.     if ((dsPtr->length == 0)
  1912.         || ((dsPtr->length == 1) && (dsPtr->string[0] == '{'))
  1913.         || ((dsPtr->length > 1) && (dsPtr->string[dsPtr->length-1] == '{')
  1914.             && (dsPtr->string[dsPtr->length-2] != '\\'))) {
  1915.     Tcl_DStringAppend(dsPtr, "{", -1);
  1916.     } else {
  1917.     Tcl_DStringAppend(dsPtr, " {", -1);
  1918.     }
  1919. }
  1920.  
  1921. /*
  1922.  *----------------------------------------------------------------------
  1923.  *
  1924.  * Tcl_DStringEndSublist --
  1925.  *
  1926.  *    This procedure adds the necessary characters to a dynamic
  1927.  *    string to end a sublist (e.g. "}").  Future element appends
  1928.  *    will be in the enclosing (sub)list rather than the current
  1929.  *    sublist.
  1930.  *
  1931.  * Results:
  1932.  *    None.
  1933.  *
  1934.  * Side effects:
  1935.  *    None.
  1936.  *
  1937.  *----------------------------------------------------------------------
  1938.  */
  1939.  
  1940. void
  1941. Tcl_DStringEndSublist(dsPtr)
  1942.     Tcl_DString *dsPtr;            /* Dynamic string. */
  1943. {
  1944.     Tcl_DStringAppend(dsPtr, "}", -1);
  1945. }
  1946.  
  1947. /*
  1948.  *----------------------------------------------------------------------
  1949.  *
  1950.  * Tcl_PrintDouble --
  1951.  *
  1952.  *    Given a floating-point value, this procedure converts it to
  1953.  *    an ASCII string using.
  1954.  *
  1955.  * Results:
  1956.  *    The ASCII equivalent of "value" is written at "dst".  It is
  1957.  *    written using the current precision, and it is guaranteed to
  1958.  *    contain a decimal point or exponent, so that it looks like
  1959.  *    a floating-point value and not an integer.
  1960.  *
  1961.  * Side effects:
  1962.  *    None.
  1963.  *
  1964.  *----------------------------------------------------------------------
  1965.  */
  1966.  
  1967. void
  1968. Tcl_PrintDouble(interp, value, dst)
  1969.     Tcl_Interp *interp;            /* Interpreter whose tcl_precision
  1970.                      * variable controls printing. */
  1971.     double value;            /* Value to print as string. */
  1972.     char *dst;                /* Where to store converted value;
  1973.                      * must have at least TCL_DOUBLE_SPACE
  1974.                      * characters. */
  1975. {
  1976.     register char *p;
  1977.     sprintf(dst, ((Interp *) interp)->pdFormat, value);
  1978.  
  1979.     /*
  1980.      * If the ASCII result looks like an integer, add ".0" so that it
  1981.      * doesn't look like an integer anymore.  This prevents floating-point
  1982.      * values from being converted to integers unintentionally.
  1983.      */
  1984.  
  1985.     for (p = dst; *p != 0; p++) {
  1986.     if ((*p == '.') || (isalpha(UCHAR(*p)))) {
  1987.         return;
  1988.     }
  1989.     }
  1990.     p[0] = '.';
  1991.     p[1] = '0';
  1992.     p[2] = 0;
  1993. }
  1994.  
  1995. /*
  1996.  *----------------------------------------------------------------------
  1997.  *
  1998.  * TclPrecTraceProc --
  1999.  *
  2000.  *    This procedure is invoked whenever the variable "tcl_precision"
  2001.  *    is written.
  2002.  *
  2003.  * Results:
  2004.  *    Returns NULL if all went well, or an error message if the
  2005.  *    new value for the variable doesn't make sense.
  2006.  *
  2007.  * Side effects:
  2008.  *    If the new value doesn't make sense then this procedure
  2009.  *    undoes the effect of the variable modification.  Otherwise
  2010.  *    it modifies the format string that's used by Tcl_PrintDouble.
  2011.  *
  2012.  *----------------------------------------------------------------------
  2013.  */
  2014.  
  2015.     /* ARGSUSED */
  2016. char *
  2017. TclPrecTraceProc(clientData, interp, name1, name2, flags)
  2018.     ClientData clientData;    /* Not used. */
  2019.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  2020.     char *name1;        /* Name of variable. */
  2021.     char *name2;        /* Second part of variable name. */
  2022.     int flags;            /* Information about what happened. */
  2023. {
  2024.     register Interp *iPtr = (Interp *) interp;
  2025.     char *value, *end;
  2026.     int prec;
  2027.  
  2028.     /*
  2029.      * If the variable is unset, then recreate the trace and restore
  2030.      * the default value of the format string.
  2031.      */
  2032.  
  2033.     if (flags & TCL_TRACE_UNSETS) {
  2034.     if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) {
  2035.         Tcl_TraceVar2(interp, name1, name2,
  2036.             TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  2037.             TclPrecTraceProc, clientData);
  2038.     }
  2039.     strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT);
  2040.     iPtr->pdPrec = DEFAULT_PD_PREC;
  2041.     return (char *) NULL;
  2042.     }
  2043.  
  2044.     value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
  2045.     if (value == NULL) {
  2046.     value = "";
  2047.     }
  2048.     prec = strtoul(value, &end, 10);
  2049.     if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) ||
  2050.         (end == value) || (*end != 0)) {
  2051.     char oldValue[10];
  2052.  
  2053.     sprintf(oldValue, "%d", iPtr->pdPrec);
  2054.     Tcl_SetVar2(interp, name1, name2, oldValue, flags & TCL_GLOBAL_ONLY);
  2055.     return "improper value for precision";
  2056.     }
  2057.     sprintf(iPtr->pdFormat, "%%.%dg", prec);
  2058.     iPtr->pdPrec = prec;
  2059.     return (char *) NULL;
  2060. }
  2061.